home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / fortran / clpfor.com / EX.F < prev    next >
Encoding:
Text File  |  1989-01-21  |  12.6 KB  |  419 lines
  1. C**************************************************************************
  2. C>>NUMBER-CRUNSHER CLIPPER> > > > > >>OR<< < < < <RENASCENCE FOR FORTRAN<<*
  3. C**************************************************************************
  4. C       Advanced Interface: Clipper(Su'87) & Microsoft Fortran 4.x        * 
  5. C        (See Ed Bell's Interface to Ratfor in NanNews 9/10 '88.)         * 
  6. C-------------------------------------------------------------------------*
  7. C                   (c) Jobst Hensiek,  January 1989                      * 
  8. C Claustorwall 23 / D - 3380 Goslar 1 / WEST Germany / 011-495-321-4457   *
  9. C                   CLIPPER(tm) of NANTUCKET CORP.                        *
  10. C                MS FORTRAN 4.1 (tm) of MICROSOFT CORP.                   *
  11. C**************************************************************************
  12. C
  13. C What you need: 
  14. C         1. Clipper Su '87  
  15. C         2. MS-Fortran 4.x (...)
  16. C            (Install LLIBFORA to !!NO!! C-compatability, otherwise you 
  17. C              will have to link LLIBCA as well!!)
  18. C         3. File EXTOR.OBJ (Included in R. McConnell's C-Goodies, PD) 
  19. C            (I put it in this ARC)       
  20. C
  21. C What you should keep in mind: 
  22. C         1.) Include this file 'EX.F' at the top of your FORTRAN application  
  23. C             ==> $INCLUDE:'EX.F'
  24. C         2.) Declare the FORTRAN-SUB in your Clipper-file as EXTERNAL. 
  25. C         3.) Your Fortran application should be a SUBROUTINE.
  26. C         4.) SET FL=/c /AL /FPa /Olt /Gs /Zl <FILE.FOR> ; Compiler switches
  27. C         5.) PLINK86 FI <CLIPPER.OBJ>,<FORTRAN.OBJ>,<EXTOR.OBJ> 
  28. C                     SEARCH CLIPPER,LLIBFORA      
  29. C         6.) Use $LARGE, or set the '/Gtxxxx'(CAREFULL) - Compiler Switch.                        
  30. C              ($LARGE IS SAFE!)
  31. C
  32. C If you have new idea's:
  33. C         1.) Post a msg to :76656,1606 (CompuServe)
  34. C             But DON'T waste your money on the phone.
  35. C             **** I live at least six hour's ahead of you (EASTERN TIME+6)!   
  36. C
  37. $LARGE
  38. C Pass String to Fortran
  39. C CLIPPER: x=CLPFOR("STRING")
  40. C FORTRAN: CHARACTER*N A,PARC     * N String-Length, declare PARC and A 
  41. C          A=PARC(ORDER [,INDEX)
  42.        INTERFACE TO CHARACTER*(*) FUNCTION PARC 
  43.      + [C, VARYING, ALIAS:'__parc'] (N) 
  44.        INTEGER*2 N 
  45.        END 
  46.  
  47. C Pass reserved String-LENGTH to Fortran
  48. C CLIPPER: X=SPACE(40)
  49. C          X="STRING"
  50. C          Y=CLPFOR(@X)
  51. C FORTRAN: INTEGER*2 N,PARCSZ           * N String-Length, declare PARCSZ, N 
  52. C          N=PARCSZ(ORDER [,INDEX)
  53.        INTERFACE TO INTEGER*2 FUNCTION PARCSZ 
  54.      + [C, VARYING, ALIAS:'__parcsiz'] (N) 
  55.        INTEGER*2 N 
  56.        END 
  57.                                         
  58. C Pass String-LENGTH to Fortran
  59. C CLIPPER: X="STRING"
  60. C          Y=CLPFOR(X)
  61. C FORTRAN: INTEGER*2 N,PARCLN          * N String-Length, declare PARCLN, N 
  62. C          N=PARCLN(ORDER [,INDEX)
  63.        INTERFACE TO INTEGER*2 FUNCTION PARCLN 
  64.      + [C, VARYING, ALIAS:'__parclen'] (N) 
  65.        INTEGER*2 N 
  66.        END 
  67.  
  68. C Pass INTEGER to Fortran
  69. C CLIPPER: X=69
  70. C          Y=CLPFOR(X)
  71. C FORTRAN: INTEGER*2 N,PARNI           * declare PARNI and N 
  72. C          N=PARNI(ORDER [,INDEX)
  73.        INTERFACE TO INTEGER*2 FUNCTION PARNI 
  74.      + [C, VARYING, ALIAS:'__parni'] (N) 
  75.        INTEGER*2 N 
  76.        END 
  77.  
  78. C Pass LONG-INTEGER to Fortran
  79. C CLIPPER: X=9696969
  80. C          Y=CLPFOR(X)
  81. C FORTRAN: INTEGER*4 N,PARNL           * declare PARNL and N 
  82. C          N=PARNI(ORDER [,INDEX)
  83.        INTERFACE TO INTEGER*4 FUNCTION PARNL 
  84.      + [C, VARYING, ALIAS:'__parnl'] (N) 
  85.        INTEGER*2 N 
  86.        END 
  87.  
  88. C Pass DOUBLE to Fortran
  89. C CLIPPER: X=96,96969
  90. C          Y=CLPFOR(X)
  91. C FORTRAN: REAL*8 X,PARND              * declare PARND and X 
  92. C          X=PARND(ORDER [,INDEX)
  93.        INTERFACE TO REAL*8 FUNCTION PARND 
  94.      + [C, VARYING, ALIAS:'__parnd'] (N) 
  95.        INTEGER*2 N 
  96.        END 
  97.  
  98. C Pass LOGICAL to Fortran
  99. C CLIPPER: X=.T.
  100. C          Y=CLPFOR(X)
  101. C FORTRAN: INTEGER*2 N,PARL             * declare PARL, N, L and INLOG 
  102. C          LOGICAL*2 INLOG,L            * 
  103. C          L=INLOG(PARL(ORDER [,INDEX))
  104.        INTERFACE TO INTEGER*2 FUNCTION PARL 
  105.      + [C, VARYING, ALIAS:'__parl'] (N) 
  106.        INTEGER*2 N 
  107.        END 
  108.  
  109. C Pass DATE-STRING to Fortran
  110. C CLIPPER: X=CTOD("09\06\96")
  111. C          Y=CLPFOR(X)
  112. C FORTRAN: CHARACTER*8 A,PARDS          * declare PARDS and A 
  113. C          N=PARDS(ORDER [,INDEX)
  114.        INTERFACE TO CHARACTER*8 FUNCTION PARDS 
  115.      + [C, VARYING, ALIAS:'__pards'] (N) 
  116.        INTEGER*2 N 
  117.        END 
  118.  
  119. C Get STRING-LENGTH in Fortran
  120. C FORTRAN: CHARACTER*20 A               * declare A,N
  121. C          INTEGER*2 N 
  122. C          a='STRING'\\CHAR(0)
  123. C          N=STRLEN(A)
  124.        INTERFACE TO INTEGER*2 FUNCTION STRLEN 
  125.      + [C,ALIAS:'_strlen'] (STR) 
  126.        CHARACTER*(*) STR [REFERENCE]  
  127.        END 
  128.   
  129. C--------------------------------------------------------------------
  130. C  CLIPPER -<FUNCTION>- RETURN VALUES 
  131. C  All data-types have to declared! (You know what I mean!?)
  132. C
  133. C  !DON't RETURN MORE THAN ONE VALUE OR STRING, OR KILL THE STACK!
  134. C                                                    
  135. C Push STRING to CLIPPER
  136. C FORTRAN: A='Hello Ed'
  137. C          CALL RETC(A)
  138. C CLIPPER: Y=CLPFOR(X)
  139. C          Y -< Hello Ed
  140.        INTERFACE TO SUBROUTINE RETC 
  141.      + [C, ALIAS:'__retc'] (STR) 
  142.        CHARACTER*(*) STR [REFERENCE] 
  143.        END 
  144.  
  145. C Push STRING to CLIPPER
  146. C FORTRAN: A='Hello Ed'
  147. C          CALL RCLEN('A')
  148. C CLIPPER: Y=CLPFOR(X)
  149. C          Y -< 8
  150.        INTERFACE TO SUBROUTINE RCLEN 
  151.      + [C, ALIAS:'__retclen'] (STR,N) 
  152.        CHARACTER*(*) STR [REFERENCE]  
  153.        INTEGER*2 N 
  154.        END 
  155.  
  156. C Push INTEGER to CLIPPER
  157. C FORTRAN: N=69
  158. C          CALL RETNI(N)
  159. C CLIPPER: Y=CLPFOR(X)
  160. C          Y -< 69
  161.        INTERFACE TO SUBROUTINE RETNI 
  162.      + [C, ALIAS:'__retni'] (N) 
  163.        INTEGER*2 N 
  164.        END 
  165.  
  166. C Push LONG-INTEGER to CLIPPER
  167. C FORTRAN: N=6969696969
  168. C          CALL RETNL(N)
  169. C CLIPPER: Y=CLPFOR(X)
  170. C          Y -< 6969696969
  171.        INTERFACE TO SUBROUTINE RETNL 
  172.      + [C, ALIAS:'__retnl'] (N) 
  173.        INTEGER*4 N 
  174.        END 
  175.  
  176. C Push DOUBLE to CLIPPER
  177. C FORTRAN: X=69,69696969
  178. C          CALL RETND(N)
  179. C CLIPPER: Y=CLPFOR(X)
  180. C          Y -< 69,69696969
  181.        INTERFACE TO SUBROUTINE RETND 
  182.      + [C, ALIAS:'__retnd'] (N) 
  183.        REAL*8 N 
  184.        END 
  185.  
  186. C Push LOGICAL to CLIPPER
  187. C FORTRAN: L=.TRUE.
  188. C          CALL RETL(LOGIN(L))
  189. C CLIPPER: Y=CLPFOR(X)
  190. C          Y -<.T.
  191.        INTERFACE TO SUBROUTINE RETL 
  192.      + [C, ALIAS:'__retl'] (N) 
  193.        INTEGER*2 N 
  194.        END 
  195.  
  196. C Push DATE-STRING to CLIPPER
  197. C FORTRAN: A='19690606'
  198. C          CALL RETDS(A)
  199. C CLIPPER: Y=CLPFOR(X)
  200. C          Y < 06\06\69
  201.        INTERFACE TO SUBROUTINE RETDS 
  202.      + [C, ALIAS:'__retds'] (DSTR) 
  203.        CHARACTER*8 DSTR [REFERENCE]  
  204.        END 
  205.  
  206. C It cleans up the stack, i guess (?)
  207.        INTERFACE TO SUBROUTINE RET 
  208.      + [C, ALIAS:'__ret']  
  209.        END 
  210.  
  211. C      ALLOCATE MEMORY. 
  212. C      PARAMETER: REQUESTED SIZE IN BYTES. 
  213. C      RETURNS FAR POINTER TO MEMORY OR NULL. 
  214.  
  215.        INTERFACE TO INTEGER*4 FUNCTION XMGRAB 
  216.      + [C, ALIAS:'__exmgrab'] (N) 
  217.        INTEGER*2 N 
  218.        END 
  219.  
  220.        INTERFACE TO SUBROUTINE XMBACK 
  221.      + [C, ALIAS:'__exmback'] (I, J) 
  222.        INTEGER*4 I [REFERENCE] 
  223.        INTEGER*2 J 
  224.        END 
  225. C ---------------------------------------------------------------------- 
  226. C  Be sure, ALL PARAMETERS passed by REFERENCE from Clipper: <'@X'> !
  227. C  McConnell's EXTOR-SYSTEM is very usefull for doing MATH with Clipper!
  228. C  - This is my personal opinion.
  229. C
  230. C  !FEEL FREE TO RETURN MORE THAN ONE VALUE OR STRING, THE STACK LIKES IT!
  231. C
  232. C Push DOUBLE back to CLIPPER
  233. C FORTRAN: CALL STRND(VALUE, ORDER [,INDEX)
  234.        INTERFACE TO SUBROUTINE STRND 
  235.      + [C, VARYING, ALIAS:'__stornd'] (X,N) 
  236.        REAL*8 X   
  237.        INTEGER*2 N 
  238.        END 
  239.  
  240. C Push DOUBLE with DECIMAL's back to CLIPPER
  241. C FORTRAN: CALL STRNDC(VALUE, DECIMAL, ORDER [,INDEX)
  242.        INTERFACE TO SUBROUTINE STRNDC 
  243.      + [C, VARYING, ALIAS:'__storndec'] (X,K,N) 
  244.        REAL*8 X  
  245.        INTEGER*2 K,N 
  246.        END 
  247.  
  248. C Push LONG-INTEGER back to CLIPPER
  249. C FORTRAN: CALL STRNL(VALUE, ORDER [,INDEX)
  250.        INTERFACE TO SUBROUTINE STRNL 
  251.      + [C, VARYING, ALIAS:'__stornl'] (K,N) 
  252.        INTEGER*4 K  
  253.        INTEGER*2 N  
  254.        END 
  255.  
  256. C Push INTEGER back to CLIPPER
  257. C FORTRAN: CALL STRNI(VALUE, ORDER [,INDEX)
  258.        INTERFACE TO SUBROUTINE STRNI 
  259.      + [C, VARYING, ALIAS:'__storni'] (K,N) 
  260.        INTEGER*2 K,N
  261.        END 
  262.  
  263. C Push STRING back to CLIPPER
  264. C FORTRAN: CALL STRC('STRING', ORDER [,INDEX)
  265.        INTERFACE TO SUBROUTINE STRC 
  266.      + [C, VARYING, ALIAS:'__storc'] (STR,N) 
  267.        CHARACTER*(*) STR [REFERENCE] 
  268.        INTEGER*2 N 
  269.        END 
  270.  
  271. C Push LOGICAL back to Clipper
  272. C FORTRAN: CALL STRL(FLAG , ORDER [,INDEX)
  273.        INTERFACE TO SUBROUTINE STRL 
  274.      + [C, VARYING, ALIAS:'__storl'] (K,N) 
  275.        INTEGER*2 K,N
  276.        END 
  277.  
  278. C Push STRING-LEN back to CLIPPER
  279. C FORTRAN: A='STRING'//CHAR(0)
  280. C          CALL STRCLN(A, ORDER [,INDEX)
  281.        INTERFACE TO SUBROUTINE STRCLN 
  282.      + [C, VARYING, ALIAS:'__storclen'] (STR,K,N) 
  283.        CHARACTER*(*) STR [REFERENCE] 
  284.        INTEGER*2 K,N  
  285.        END 
  286.  
  287. C Push DATE-STRING back to CLIPPER
  288. C FORTRAN: CALL STRDS('DATE-STRING', ORDER [,INDEX)
  289.        INTERFACE TO SUBROUTINE STRDS 
  290.      + [C,VARYING,ALIAS:'__stords'] (DSTR,N) 
  291.        CHARACTER*8 DSTR [REFERENCE] 
  292.        INTEGER*2 N 
  293.        END 
  294.  
  295. C Convert LOGICAL to INTEGER
  296. C FORTRAN: CALL STORL(LOGIN(FLAG)) and pass it to Clipper
  297.        INTEGER*2 FUNCTION LOGIN(L) 
  298.        LOGICAL*2 L [VALUE]
  299.        LOGIN=0
  300.        IF(L)LOGIN=1
  301.        RETURN
  302.        END
  303. C-------------------------------------------------------------------------
  304. C A FUNCTION !!!MUST!!!ALWAYS!!! BE DECLARED IN THE CALLING SUBROUTINE!
  305. C EXAMPLE: INTEGER*2 ALNGTH,N
  306. C          N=ALNGTH(ORDER)
  307. C
  308.  
  309. C Get Parameter Info. (Used in functions below)
  310.        INTERFACE TO INTEGER*2 FUNCTION PINFO  
  311.      + [C, ALIAS:'__parinfo'] (N) 
  312.        INTEGER*2 N 
  313.        END 
  314.  
  315. C Get Array-Parameter Info. (Used in functions below)
  316.        INTERFACE TO INTEGER*2 FUNCTION PINFA 
  317.      + [C, ALIAS: '__parinfa'] (K,N) 
  318.        INTEGER*2 K,N 
  319.        END 
  320.  
  321. C Convert INTEGER to LOGICAL
  322. C FORTRAN: X=INLOG(PARL(ORDER))  
  323.        LOGICAL*2 FUNCTION INLOG(N) 
  324.        INTEGER*2 N [VALUE]
  325.        INLOG=.FALSE.
  326.        IF(N.EQ.1)INLOG=.TRUE.
  327.        RETURN
  328.        END
  329.  
  330. C Number of Parameters passed
  331. C FORTRAN: N=PCOUNT()
  332.        INTEGER*2 FUNCTION PCOUNT  
  333.        INTEGER*2 PINFO 
  334.        PCOUNT=PINFO(0) 
  335.        RETURN 
  336.        END  
  337.  
  338. C Size of array (INDEX - COUNT)
  339. C FORTRAN: N=ALNGTH(ORDER)
  340.        INTEGER*2 FUNCTION ALNGTH(N) 
  341.        INTEGER*2 N [VALUE] 
  342.        INTEGER*2 PINFA 
  343.        ALNGTH=PINFA(N,0) 
  344.        RETURN 
  345.        END  
  346.  
  347. C Gives .TRUE. for a CHARACTER
  348. C FORTRAN: L=ISCHAR(ORDER)
  349.        LOGICAL*2 FUNCTION ISCHAR(N)  
  350.        INTEGER*2 N [VALUE] 
  351.        INTEGER*2 PINFO,INF  
  352.        INF=PINFO(N) 
  353.        ISCHAR=.FALSE. 
  354.        IF ((INF.EQ.1).OR.(INF.EQ.33))ISCHAR=.TRUE. 
  355.        RETURN 
  356.        END 
  357.  
  358. C Gives .TRUE. for a NUMBER
  359.        LOGICAL*2 FUNCTION ISNUM(N) 
  360.        INTEGER*2 N [VALUE] 
  361.        INTEGER*2 PINFO,INF 
  362.        INF=PINFO(N) 
  363.        ISNUM=.FALSE. 
  364.        IF ((INF.EQ.2).OR.(INF.EQ.34))ISNUM=.TRUE. 
  365.        RETURN 
  366.        END 
  367.  
  368. C Gives .TRUE. for a LOGICAL
  369.        LOGICAL*2 FUNCTION ISLOG(N) 
  370.        INTEGER*2 N [VALUE] 
  371.        INTEGER*2 PINFO,INF 
  372.        INF=PINFO(N) 
  373.        ISLOG=.FALSE. 
  374.        IF ((INF.EQ.4).OR.(INF.EQ.36))ISLOG=.TRUE. 
  375.        RETURN 
  376.        END 
  377.  
  378. C Gives .TRUE. for a DATE-STRING
  379.        LOGICAL*2 FUNCTION ISDATE(N) 
  380.        INTEGER*2 N [VALUE] 
  381.        INTEGER*2 PINFO,INF 
  382.        INF=PINFO(N) 
  383.        ISDATE=.FALSE. 
  384.        IF ((INF.EQ.8).OR.(INF.EQ.40))ISDATE=.TRUE. 
  385.        RETURN 
  386.        END 
  387.  
  388. C Ceck for Memo (?)
  389.        LOGICAL*2 FUNCTION ISMEMO(N) 
  390.        INTEGER*2 N [VALUE] 
  391.        INTEGER*2 PINFO,INF 
  392.        INF=PINFO(N) 
  393.        ISMEMO=.FALSE. 
  394.        IF ((INF.EQ.65).OR.(INF.EQ.97))ISMEMO=.TRUE. 
  395.        RETURN 
  396.        END 
  397.  
  398. C Gives .TRUE. for a ARRAY  
  399.        LOGICAL*2 FUNCTION ISARRY(N) 
  400.        INTEGER*2 N [VALUE] 
  401.        INTEGER*2 PINFO,INF 
  402.        INF=PINFO(N) 
  403.        ISARRY=.FALSE. 
  404.        IF ((INF.EQ.512).OR.(INF.EQ.544))ISARRY=.TRUE. 
  405.        RETURN 
  406.        END 
  407.  
  408. C   Header structure. 
  409.        SUBROUTINE DBF 
  410.        COMMON /DBFBLK/SIG,YMD,LREC,DATA_OFF,REC_SIZE,PAD 
  411.        CHARACTER*1  SIG 
  412.        CHARACTER*3  YMD 
  413.        INTEGER*4    LREC 
  414.        INTEGER*2    DATA_OFF 
  415.        INTEGER*2    REC_SIZE 
  416.        CHARACTER*20 PAD(20) 
  417.        RETURN 
  418.        END 
  419.